home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_perl.idb / usr / freeware / lib / perl5 / 5.00502 / B / Disassembler.pm.z / Disassembler.pm
Encoding:
Perl POD Document  |  1998-10-28  |  3.3 KB  |  165 lines
  1. #      Disassembler.pm
  2. #
  3. #      Copyright (c) 1996 Malcolm Beattie
  4. #
  5. #      You may distribute under the terms of either the GNU General Public
  6. #      License or the Artistic License, as specified in the README file.
  7. package B::Disassembler::BytecodeStream;
  8. use FileHandle;
  9. use Carp;
  10. use B qw(cstring cast_I32);
  11. @ISA = qw(FileHandle);
  12. sub readn {
  13.     my ($fh, $len) = @_;
  14.     my $data;
  15.     read($fh, $data, $len);
  16.     croak "reached EOF while reading $len bytes" unless length($data) == $len;
  17.     return $data;
  18. }
  19.  
  20. sub GET_U8 {
  21.     my $fh = shift;
  22.     my $c = $fh->getc;
  23.     croak "reached EOF while reading U8" unless defined($c);
  24.     return ord($c);
  25. }
  26.  
  27. sub GET_U16 {
  28.     my $fh = shift;
  29.     my $str = $fh->readn(2);
  30.     croak "reached EOF while reading U16" unless length($str) == 2;
  31.     return unpack("n", $str);
  32. }
  33.  
  34. sub GET_U32 {
  35.     my $fh = shift;
  36.     my $str = $fh->readn(4);
  37.     croak "reached EOF while reading U32" unless length($str) == 4;
  38.     return unpack("N", $str);
  39. }
  40.  
  41. sub GET_I32 {
  42.     my $fh = shift;
  43.     my $str = $fh->readn(4);
  44.     croak "reached EOF while reading I32" unless length($str) == 4;
  45.     return cast_I32(unpack("N", $str));
  46. }
  47.  
  48. sub GET_objindex { 
  49.     my $fh = shift;
  50.     my $str = $fh->readn(4);
  51.     croak "reached EOF while reading objindex" unless length($str) == 4;
  52.     return unpack("N", $str);
  53. }
  54.  
  55. sub GET_strconst {
  56.     my $fh = shift;
  57.     my ($str, $c);
  58.     while (defined($c = $fh->getc) && $c ne "\0") {
  59.     $str .= $c;
  60.     }
  61.     croak "reached EOF while reading strconst" unless defined($c);
  62.     return cstring($str);
  63. }
  64.  
  65. sub GET_pvcontents {}
  66.  
  67. sub GET_PV {
  68.     my $fh = shift;
  69.     my $str;
  70.     my $len = $fh->GET_U32;
  71.     if ($len) {
  72.     read($fh, $str, $len);
  73.     croak "reached EOF while reading PV" unless length($str) == $len;
  74.     return cstring($str);
  75.     } else {
  76.     return '""';
  77.     }
  78. }
  79.  
  80. sub GET_comment {
  81.     my $fh = shift;
  82.     my ($str, $c);
  83.     while (defined($c = $fh->getc) && $c ne "\n") {
  84.     $str .= $c;
  85.     }
  86.     croak "reached EOF while reading comment" unless defined($c);
  87.     return cstring($str);
  88. }
  89.  
  90. sub GET_double {
  91.     my $fh = shift;
  92.     my ($str, $c);
  93.     while (defined($c = $fh->getc) && $c ne "\0") {
  94.     $str .= $c;
  95.     }
  96.     croak "reached EOF while reading double" unless defined($c);
  97.     return $str;
  98. }
  99.  
  100. sub GET_none {}
  101.  
  102. sub GET_op_tr_array {
  103.     my $fh = shift;
  104.     my @ary = unpack("n256", $fh->readn(256 * 2));
  105.     return join(",", @ary);
  106. }
  107.  
  108. sub GET_IV64 {
  109.     my $fh = shift;
  110.     my ($hi, $lo) = unpack("NN", $fh->readn(8));
  111.     return sprintf("0x%4x%04x", $hi, $lo); # cheat
  112. }
  113.  
  114. package B::Disassembler;
  115. use Exporter;
  116. @ISA = qw(Exporter);
  117. @EXPORT_OK = qw(disassemble_fh);
  118. use Carp;
  119. use strict;
  120.  
  121. use B::Asmdata qw(%insn_data @insn_name);
  122.  
  123. sub disassemble_fh {
  124.     my ($fh, $out) = @_;
  125.     my ($c, $getmeth, $insn, $arg);
  126.     bless $fh, "B::Disassembler::BytecodeStream";
  127.     while (defined($c = $fh->getc)) {
  128.     $c = ord($c);
  129.     $insn = $insn_name[$c];
  130.     if (!defined($insn) || $insn eq "unused") {
  131.         my $pos = $fh->tell - 1;
  132.         die "Illegal instruction code $c at stream offset $pos\n";
  133.     }
  134.     $getmeth = $insn_data{$insn}->[2];
  135.     $arg = $fh->$getmeth();
  136.     if (defined($arg)) {
  137.         &$out($insn, $arg);
  138.     } else {
  139.         &$out($insn);
  140.     }
  141.     }
  142. }
  143.  
  144. 1;
  145.  
  146. __END__
  147.  
  148. =head1 NAME
  149.  
  150. B::Disassembler - Disassemble Perl bytecode
  151.  
  152. =head1 SYNOPSIS
  153.  
  154.     use Disassembler;
  155.  
  156. =head1 DESCRIPTION
  157.  
  158. See F<ext/B/B/Disassembler.pm>.
  159.  
  160. =head1 AUTHOR
  161.  
  162. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  163.  
  164. =cut
  165.